;;; xml-indent.el --- an indentation-engine for XML

;; Copyright (C) 2001   Mike Williams <mdub@bigfoot.com>

;; Author:     Mike Williams <mdub@bigfoot.com>
;; Created:    February 2001
;; Version:    0.1
;; Keywords:   xml

;; This file is not part of GNU Emacs.

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2 of the License, or
;; (at your option) any later version.
;; 
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;; 
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:
;;
;; This package provides a simple indentation engine for XML.  It is
;; intended for use in situations where the full power of the popular PSGML
;; package (DTD parsing, syntax checking) is not required.
;;
;; xml-indent is designed to be used in conjunction with the default GNU
;; Emacs sgml-mode, to provide a lightweight XML-editing environment.

;;; Bugs/Limitations:
;;
;; - Doesn't handle CDATA sections

;;; Code:

(defvar xml-indent-offset 2 
  "*Specifies the indentation-step for \\[xml-indent-line].")


;; Parsing 

(defmacro xml-parse-safe (&rest body)
  ;; safely execute BODY, return nil if an error occurred
  `(condition-case nil
       (progn ,@body)
     (error nil)))

(defun xml-parse-tag-name ()
  "Skip past a tag-name, and return the name."
  (let ((here (point)))
    (if (> (skip-chars-forward "A-Za-z0-9_:") 0)
        (buffer-substring-no-properties here (point)))))
  
(defun xml-parse-tag-backward ()
  "Get information about the parent tag."
  (let ((limit (point))
        (tag-type 'start)
        tag-start tag-end
        name name-end)
    
    ;; determine tag limits
    (setq tag-start (search-backward "<"))
    (setq tag-end (search-forward ">" limit t))
    
    ;; work out tag type
    (goto-char (1+ tag-start))
    (cond
     
     ((= ?? (char-after)) 
      (setq tag-type 'pi))
     
     ((= ?! (char-after))
      (setq tag-type 'comment))
     
     ((= ?/ (char-after))
      (goto-char (+ 2 tag-start))
      (setq tag-type 'end
            name (xml-parse-tag-name)
            name-end (point)))
     
     (t
      (setq tag-type 'start
            name (xml-parse-tag-name)
            name-end (point))))
    
    ;; check whether it's an empty tag
    (if (and tag-end (eq ?/ (char-before (- tag-end 1))))
        (setq tag-type 'empty))
    
    (goto-char tag-start)
    (list tag-type 
          tag-start tag-end 
          name name-end)))

(defsubst xml-tag-type (tag-info)
  (nth 0 tag-info))

(defsubst xml-tag-start (tag-info)
  (nth 1 tag-info))

(defsubst xml-tag-end (tag-info)
  (nth 2 tag-info))

(defsubst xml-tag-name (tag-info)
  (nth 3 tag-info))

(defsubst xml-tag-name-end (tag-info)
  (nth 4 tag-info))

(defun xml-get-context ()
  "Determine the context of the current position."
  (let ((here (point))
        (level 0)
        tag-info end-tag-info
        stack context)
    (xml-parse-safe 
     (save-excursion
       (while (null context)
         (setq tag-info (xml-parse-tag-backward))
         (cond
          ;; inside a tag ...
          ((null (xml-tag-end tag-info))
           (setq context (list 'tag tag-info)))
          ;; start-tag
          ((eq (xml-tag-type tag-info) 'start)
           (setq level (1- level))
           (when (< level 0)
             (setq stack (cons tag-info stack))
             (goto-char (xml-tag-start tag-info))
             (skip-chars-backward " \t")
             (if (bolp)
                 (setq context (cons 'elt stack)))))
          ;; end-tag
          ((eq (xml-tag-type tag-info) 'end)
           (setq level (1+ level))) 
          ))
       ))
    ;; return context
    context))


;; Indenting
             
(defun xml-calculate-indent ()
  "Calculate the column to which this line should be indented."
  (let* ((context (xml-get-context))
         (context-type (car context))
         (tag-info (nth 1 context))
         indent-col)
      
    (save-excursion
      (cond
       
       ;; no context
       ((null context)
        0)
       
       ;; inside a tag
       ((eq context-type 'tag)
        ;; indent to end of tag-name, plus one
        (goto-char (xml-tag-name-end tag-info))
        (1+ (current-column)))
       
       ;; inside an element
       ((eq context-type 'elt)
        ;; indent to start of tag
        (let ((here (point))
              indent-col)
          (goto-char (xml-tag-start tag-info))
          (setq indent-col (current-column))
          (goto-char here)
          ;; add xml-indent-offset, unless we're looking at the matching
          ;; end-tag
          (unless (and (null (nth 2 context)) (looking-at "</"))
            (setq indent-col (+ indent-col xml-indent-offset)))
          indent-col))
          
       ;; default
       (t 0)
       ))))
    
(defun xml-indent-line ()
  "Indent the current line as XML."
  (interactive)
  (let ((origin-point (point))
        bol-point indent-point
        indent-col)

    ;; save beginning of line
    (beginning-of-line)
    (setq bol-point (point))
    ;; save current indent
    (skip-chars-forward " \t")
    (setq indent-point (point))

    ;; calculate basic indent
    (setq indent-col (xml-calculate-indent))

    (unless (eq (current-column) indent-col)
      ;; re-indent, adjusting origin point for indentation change
      (delete-region bol-point (point))
      (indent-to indent-col)
      (setq origin-point (+ origin-point (- (point) indent-point))))
    
    (if (> origin-point (point))
        (goto-char origin-point))
    
    ))


;; Editing shortcuts

(defun xml-insert-end-tag ()
  "Insert an end-tag for the current element."
  (interactive)
  (let* ((context (xml-get-context))
         (context-type (car context))
         (tag-info (car (last context))))
    (unless (eq context-type 'elt)
      (error "Not inside an element"))
    (insert "</" (xml-tag-name tag-info) ">")
    (xml-indent-line)))


;; Movement commands

(defun forward-xml-tag (arg)
  (interactive "p")
  (cond
   ((> arg 0)
    (search-forward ">" nil nil arg))
   ((< arg 0)
    (search-backward "<" nil nil (- arg)))
   ))

(defun backward-xml-tag (arg)
  (interactive "p")
  (forward-tag (- arg)))

(defun beginning-of-xml-tag ()
  (interactive)
  (if (= ?< (char-after (point)))
      (point)
    (search-backward "<")))

(defun end-of-xml-tag ()
  (interactive)
  (forward-xml-tag 1))


;; Key bindings

(define-key sgml-mode-map "\t" 'xml-indent-line)
(define-key sgml-mode-map "\C-c/" 'xml-insert-end-tag)

(provide 'xml-indent)

;;; xml-indent.el ends here

